home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / infix / pratt.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  309 lines
  1. ; -*- Mode: Scheme; -*-
  2. ;
  3. ; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM
  4. ; Siod may be obtained by anonymous FTP to world.std.com:pub/gjc.
  5. ;
  6. ; *                      COPYRIGHT (c) 1988-1994 BY                          *
  7. ; *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  8. ; *                         ALL RIGHTS RESERVED                              *
  9. ;
  10. ;Permission to use, copy, modify, distribute and sell this software
  11. ;and its documentation for any purpose and without fee is hereby
  12. ;granted, provided that the above copyright notice appear in all copies
  13. ;and that both that copyright notice and this permission notice appear
  14. ;in supporting documentation, and that the name of Paradigm Associates
  15. ;Inc not be used in advertising or publicity pertaining to distribution
  16. ;of the software without specific, written prior permission.
  17. ;
  18. ;PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  19. ;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  20. ;PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  21. ;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  22. ;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  23. ;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  24. ;SOFTWARE.
  25. ;
  26. ; Based on a theory of parsing presented in:                       
  27. ;                                                                      
  28. ;  Pratt, Vaughan R., ``Top Down Operator Precedence,''         
  29. ;  ACM Symposium on Principles of Programming Languages         
  30. ;  Boston, MA; October, 1973.                                   
  31. ;                                                                      
  32.  
  33. ; The following terms may be useful in deciphering this code:
  34.  
  35. ; NUD -- NUll left Denotation (op has nothing to its left (prefix))
  36. ; LED -- LEft Denotation      (op has something to left (postfix or infix))
  37.  
  38. ; LBP -- Left Binding Power  (the stickiness to the left)
  39. ; RBP -- Right Binding Power (the stickiness to the right)
  40. ;
  41.  
  42. ; Mods for Scheme 48 by J Rees 6-14-90
  43.  
  44. ; From: <gjc@mitech.com>
  45. ;
  46. ; Now a neat thing that CGOL had was a way of packaging and scoping
  47. ; different parsing contexts. The maclisp implementation was simple,
  48. ; instead of just NUD and LED and other properties there was a list
  49. ; of property indicators. And a lookup operation.
  50. ;
  51. ; One use of the local-context thing, in parsing the C language
  52. ; you can use a different binding-power for ":" depending on
  53. ; what kind of statement you are parsing, a general statement
  54. ; context where ":" means a label, a "switch" or the "if for value
  55. ; " construct of (a > b) > c : d;
  56.  
  57.  
  58. (define (peek-token stream)
  59.   (stream 'peek #f))
  60.  
  61. (define (read-token stream)
  62.   (stream 'get #f))
  63.    
  64. (define (toplevel-parse stream)
  65.   (if (eq? end-of-input-operator (peek-token stream))
  66.       (read-token stream)
  67.       (parse -1 stream)))
  68.  
  69.  
  70. ; A token is either an operator or atomic (number, identifier, etc.)
  71.  
  72. (define operator-type
  73.   (make-record-type 'operator
  74.             '(name lbp rbp nud led)))
  75.  
  76. (define make-operator
  77.   (let ()
  78.     (define make
  79.       (record-constructor operator-type '(name lbp rbp nud led)))
  80.     (define (make-operator name lbp rbp nud led)
  81.       (make name
  82.         (or lbp default-lbp)
  83.         (or rbp default-rbp)
  84.         (or nud default-nud)
  85.         (or led default-led)))
  86.     make-operator))
  87.  
  88. (define operator? (record-predicate operator-type))
  89.  
  90. (define operator-name (record-accessor operator-type 'name))
  91. (define operator-nud (record-accessor operator-type 'nud))
  92. (define operator-led (record-accessor operator-type 'led))
  93. (define operator-lbp (record-accessor operator-type 'lbp))
  94. (define operator-rbp (record-accessor operator-type 'rbp))
  95.  
  96. (define (default-nud operator stream)
  97.   (if (eq? (operator-led operator) default-led)
  98.       operator
  99.       (error 'not-a-prefix-operator operator)))
  100.  
  101. (define (nudcall token stream)
  102.   (if (operator? token)
  103.       ((operator-nud token) token stream)
  104.       token))
  105.  
  106. (define default-led #f)
  107.  
  108. ;+++ To do: fix this to make juxtaposition work   (f x+y)
  109.  
  110. (define (ledcall token left stream)
  111.   ((or (and (operator? token)
  112.         (operator-led token))
  113.        (error 'not-an-infix-operator token))
  114.    token
  115.    left
  116.    stream))
  117.  
  118. (define default-lbp 200)
  119.  
  120. (define (lbp token)
  121.   (if (operator? token)
  122.       (operator-lbp token)
  123.       default-lbp))
  124.  
  125. (define default-rbp 200)
  126.  
  127. (define (rbp token)
  128.   (if (operator? token)
  129.       (operator-rbp token)
  130.       default-rbp))
  131.  
  132. (define-record-discloser operator-type
  133.   (lambda (obj)
  134.     (list 'operator (operator-name obj))))
  135.  
  136. ; Mumble
  137.  
  138. (define (delim-error token stream)
  139.   (error 'invalid-use-of-delimiter token))
  140.  
  141. (define (erb-error token left stream)
  142.   (error 'too-many-right-parentheses token))
  143.  
  144. (define (premterm-err token stream)
  145.   (error 'premature-termination-of-input token))
  146.  
  147. ; Parse
  148.  
  149. (define *parse-debug* #f)
  150.  
  151. (define (parse rbp-level stream)
  152.   (if *parse-debug* (print `(parse ,rbp-level)))
  153.   (let parse-loop ((translation (nudcall (read-token stream) stream)))
  154.     (if (< rbp-level (lbp (peek-token stream)))
  155.     (parse-loop (ledcall (read-token stream) translation stream))
  156.       (begin (if *parse-debug* (print translation))
  157.          translation))))
  158.  
  159. (define (print s) (write s) (newline))
  160.  
  161. (define (parse-prefix operator stream)
  162.   (list (operator-name operator)
  163.     (parse (rbp operator) stream)))
  164.  
  165. (define (parse-infix operator left stream)
  166.   (list (operator-name operator)
  167.     left
  168.     (parse (rbp operator) stream)))
  169.  
  170. (define (parse-nary operator left stream)
  171.   (cons (operator-name operator) (cons left (prsnary operator stream))))
  172.  
  173. (define (prsnary operator stream)
  174.   (define (loop l)
  175.     (if (eq? operator (peek-token stream))
  176.     (begin (read-token stream)
  177.            (loop (cons (parse (rbp operator) stream) l)))
  178.       (reverse l)))
  179.   (loop (list (parse (rbp operator) stream))))
  180.  
  181. ; Parenthesis matching, with internal commas.
  182. ; Kind of a kludge if you ask me.
  183.  
  184. (define (parse-matchfix operator stream) ; |x|
  185.   (cons (operator-name operator)
  186.     (prsmatch operator stream)))
  187.  
  188. (define (prsmatch close-op stream)
  189.   (if (eq? (peek-token stream) close-op)
  190.       (begin (read-token stream)
  191.          '())
  192.       (let loop ((l (list (parse 10 stream))))
  193.     (if (eq? (peek-token stream) close-op)
  194.         (begin (read-token stream)
  195.            (reverse l))
  196.         (if (eq? (peek-token stream) comma-operator)
  197.         (begin (read-token stream)
  198.                (loop (cons (parse 10 stream) l)))
  199.         (error 'comma-or-match-not-found (read-token stream)))))))
  200.  
  201. (define comma-operator (make-operator 'comma 10 #f delim-error #f))
  202.  
  203. ; if A then B [else C]
  204.  
  205. (define (if-nud token stream)
  206.   (let* ((pred (parse (rbp token) stream))
  207.      (then (if (eq? (peek-token stream) then-operator)
  208.            (parse (rbp (read-token stream)) stream)
  209.            (error 'missing-then pred))))
  210.     (if (eq? (peek-token stream) else-operator)
  211.     `(if ,pred ,then ,(parse (rbp (read-token stream)) stream))
  212.     `(if ,pred ,then))))
  213.  
  214. (define if-operator (make-operator 'if #f 45 if-nud #f))
  215. (define then-operator (make-operator 'then 5 25 delim-error #f))
  216. (define else-operator (make-operator 'else 5 25 delim-error #f))
  217.  
  218. ; Lexer support:
  219.  
  220. (define lexer-type
  221.   (make-record-type 'lexer '(ttab punctab keytab)))
  222.  
  223. (define lexer-ttab    (record-accessor lexer-type 'ttab))
  224. (define lexer-punctab (record-accessor lexer-type 'punctab))
  225. (define lexer-keytab  (record-accessor lexer-type 'keytab))
  226.  
  227. (define make-lexer-table
  228.   (let ((make (record-constructor lexer-type '(ttab punctab keytab))))
  229.     (lambda ()
  230.       (let ((ttab (make-tokenizer-table)))
  231.     (set-up-usual-tokenization! ttab)
  232.     (make ttab (make-table) (make-table))))))
  233.  
  234. (define (lex ltab port)
  235.   (let ((thing (tokenize (lexer-ttab ltab) port)))
  236.     (cond ((eof-object? thing)
  237.        end-of-input-operator)
  238.       ((symbol? thing)
  239.        (or (table-ref (lexer-keytab ltab) thing)
  240.            thing))
  241.       (else thing))))
  242.  
  243. ; Keywords
  244.  
  245. (define (define-keyword ltab name op)
  246.   (table-set! (lexer-keytab ltab) name op))
  247.  
  248. ; Punctuation
  249.  
  250. ; lexnode = (* operator (table-of char (+ lexnode #f)))  -- discrimination tree
  251.  
  252. (define (define-punctuation ltab string op)
  253.   (let ((end (- (string-length string) 1)))
  254.     (let loop ((i 0)
  255.            (table (lexer-punctab ltab)))
  256.       (let* ((c (string-ref string i))
  257.          (lexnode
  258.           (or (table-ref table c)
  259.           (let ((lexnode
  260.              (cons (error-operator (substring string 0 (+ i 1)))
  261.                    (make-table))))
  262.             (table-set! table c lexnode)
  263.             (if (= i 0)
  264.             (set-char-tokenization! (lexer-ttab ltab)
  265.                         c
  266.                         (operator-reader lexnode)
  267.                         #t))
  268.             lexnode))))
  269.     (if (>= i end)
  270.         (set-car! lexnode op)
  271.         (loop (+ i 1) (cdr lexnode)))))))
  272.  
  273. (define (operator-reader lexnode)
  274.   (lambda (c port)
  275.     (let loop ((lexnode lexnode))
  276.       (let ((nextc (peek-char port)))
  277.     (let ((nextnode (table-ref (cdr lexnode) nextc)))
  278.       (if nextnode
  279.           (begin (read-char port)
  280.              (loop nextnode))
  281.           (car lexnode)))))))
  282.  
  283. (define (error-operator string)
  284.   (make-operator 'invalid-operator #f #f
  285.          (lambda rest (error "invalid operator" string))
  286.          #f))
  287.  
  288. ; Mumble
  289.  
  290. (define end-of-input-operator
  291.   (make-operator "end of input" -1 #f premterm-err #f))
  292.  
  293. (define (port->stream port ltab)
  294.   (define (really-get)
  295.     (lex ltab port))
  296.   (define peeked? #f)
  297.   (define peek #f)
  298.   (define (stream op arg)
  299.     (case op
  300.       ((get) (if peeked?
  301.          (begin (set! peeked? #f) peek)
  302.          (really-get)))
  303.       ((peek) (if peeked?
  304.           peek
  305.           (begin (set! peeked? #t)
  306.              (set! peek (really-get))
  307.              peek)))))
  308.   stream)
  309.